home *** CD-ROM | disk | FTP | other *** search
/ CD Ware Multimedia 1994 November / Cd Ware (Nro. 2) - Epimundo.iso / DOS / PG / COMBOX.ZIP / DATELIB.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-04-11  |  8.1 KB  |  327 lines
  1. Unit Datelib;
  2.  
  3. Interface
  4.  
  5. uses
  6.    Dos,
  7.    StrLib;
  8.  
  9. const
  10.    Months : array[1..12] of string[3]
  11.             = ('JAN',  'FEB',  'MAR',  'APR',  'MAY',  'JUN',
  12.                'JUL',  'AUG',  'SEP',  'OCT',  'NOV',  'DEC');
  13.    Mois   : array[1..12] of string[4]
  14.             = ('JANV', 'FEVR', 'MARS', 'AVRL', 'MAI ', 'JUIN',
  15.                'JUIL', 'AOUT', 'SEPT', 'OCTB', 'NOVM', 'DECM');
  16.    NumDays : array[1..12] of integer
  17.              = (31, 29, 31, 30, 31, 30, 30, 31, 30, 31, 30, 31);
  18.  
  19. type
  20.    TJulianDate = longint;
  21.  
  22.    TDate = record
  23.       Day   : integer;
  24.       Month : integer;
  25.       Year  : integer;
  26.       end;
  27.  
  28. Function SystemDate : longint;
  29. Function DateToJulian ( D : TDate ) : longint;
  30. Function ValidDay ( Day, Month : integer) : boolean;
  31. Function ValidDate ( S : string ) : boolean;
  32. Function ValidMonth ( Month : string ) : integer;
  33. Function LeapYear ( Year : integer ) : boolean;
  34. Function DateToStr ( Date : TDate ) : string;
  35. Function JDateToStr ( JulianDate : TJulianDate ) : string;
  36. Function StrToJDate ( S : string ) : TJulianDate;
  37. Function ExactAge(D1, D2 : TDate) : integer;
  38. Function DayOfWeek ( D : TDate ) : integer;
  39. Function DayOfWeekStr ( D : TDate ) : string;
  40. Function YearsDiff ( D1, D2 : TDate ) : integer;
  41. Function JYearsDiff ( JD1, JD2 : TJulianDate ) : integer;
  42.  
  43. Procedure StrToDate ( S : string; var Date : TDate);
  44. Procedure AssignDate ( var Date : TDate; DD, MM, YY : integer );
  45. Procedure JulianToDate ( JD : longint; var Date : TDate );
  46.  
  47. Implementation
  48.  
  49. {========================================================================}
  50.  
  51. Function SystemDate : longint;
  52.  
  53. var
  54.    DD, MM, YY, WW : word;
  55.    Date : TDate;
  56.  
  57. Begin
  58.    GetDate ( YY, MM, DD, WW );
  59.    AssignDate ( Date, DD, MM, YY );
  60.    SystemDate := DateToJulian ( Date );
  61. End;
  62.  
  63. {========================================================================}
  64.  
  65. Function YearsDiff ( D1, D2 : TDate ) : integer;
  66.  
  67. Begin
  68.    YearsDiff := abs ( D1.Year - D2.Year );
  69. End;
  70.  
  71. {========================================================================}
  72.  
  73. Function JYearsDiff ( JD1, JD2 : TJulianDate ) : integer;
  74.  
  75. var
  76.    D1, D2 : TDate;
  77.  
  78. Begin
  79.    JulianToDate ( Jd1, D1 );
  80.    JulianToDate ( Jd2, D2 );
  81.    JYearsDiff := YearsDiff ( D1, D2 );
  82. End;
  83.  
  84. {========================================================================}
  85.  
  86. Function ExactAge(D1, D2 : TDate) : integer;
  87.  
  88.   var
  89.     Age : integer;
  90.  
  91.   Begin
  92.     if DateToJulian ( D2 ) < DateToJulian ( D1 ) then
  93.       begin
  94.         ExactAge := 0;
  95.         exit;
  96.       end;
  97.     Age := D2.Year - D1.Year;
  98.     if D2.Month > D1.Month then
  99.       dec(Age);
  100.     if D2.Month = D1.Month then
  101.       if D2.Day > D1.Day then
  102.         dec(Age);
  103.     ExactAge := Age;
  104.   End;
  105.  
  106. {========================================================================}
  107.  
  108. Function DateToStr ( Date : TDate ) : string;
  109.  
  110. var
  111.    DateStr, S : string [ 12 ];
  112.  
  113. Begin
  114.    DateStr := '';
  115.    S := IntToStr ( Date.Day );
  116.    if length ( S ) = 1 then
  117.      S := '0' + S;
  118.    DateStr := DateStr + S + '-';
  119.  
  120.    S := Months [ Date.Month ];
  121.    DateStr := DateStr + S + '-';
  122.  
  123.    S := IntToStr ( Date.Year );
  124.    DateStr := DateStr + S;
  125.  
  126.    DateToStr := DateStr;
  127. End;
  128.  
  129. {========================================================================}
  130.  
  131. Function JDateToStr ( JulianDate : TJulianDate ) : string;
  132.  
  133. var
  134.    Date : TDate;
  135.  
  136. Begin
  137.    JulianToDate ( JulianDate, Date );
  138.    JDateToStr := DateToStr ( Date );
  139. End;
  140.  
  141. {========================================================================}
  142.  
  143. Procedure StrToDate ( S : string; var Date : TDate);
  144.  
  145. var
  146.    i : byte;
  147.    Month : string [ 3 ];
  148.  
  149. Begin
  150.    Date.Day := StrToInt ( S [ 1 ] + S [ 2 ] );
  151.    Month := UpCaseStr ( copy ( S, 4, 3 ) );
  152.    i := 1;
  153.    {$B-}
  154.    while ( i <= 12 ) and ( Month <> Months [ i ] ) do
  155.      inc ( i );
  156.    {$B+}
  157.    Date.Month := i;
  158.    Date.Year  := StrToInt ( copy ( S, 8, length ( S ) ) );
  159. End;
  160.  
  161. {========================================================================}
  162.  
  163. Function StrToJDate ( S : string ) : TJulianDate;
  164.  
  165. var
  166.    Date : TDate;
  167.  
  168. Begin
  169.    StrToDate ( S, Date );
  170.    StrToJDate := DateToJulian ( Date );
  171. End;
  172.  
  173. {========================================================================}
  174.  
  175. Procedure AssignDate ( var Date : TDate; DD, MM, YY : integer );
  176.  
  177. Begin
  178.    Date.Day   := DD;
  179.    Date.Month := MM;
  180.    Date.Year  := YY;
  181. End;
  182.  
  183. {========================================================================}
  184.  
  185. Function ValidMonth ( Month : string ) : integer;
  186.  
  187. var
  188.    i : integer;
  189.    Found : boolean;
  190.  
  191. Begin
  192.    Month := UpCaseStr ( Month );
  193.    i := 1;
  194.    Found := false;
  195.    while ( not Found ) and ( i <= 12 ) do
  196.       if Month = Months [ i ] then
  197.          Found := true
  198.       else
  199.          inc ( i );
  200.  
  201.     if i > 12 then
  202.        ValidMonth := 0
  203.     else
  204.        ValidMonth := i;
  205. End;
  206.  
  207. {========================================================================}
  208.  
  209. Function ValidDay ( Day, Month : integer) : boolean;
  210.  
  211. Begin
  212.    ValidDay := Day <= NumDays [ Month ];
  213. End;
  214.  
  215. {========================================================================}
  216.  
  217. Function ValidDate ( S : string ) : boolean;
  218.  
  219. var
  220.    Day, Month, Year : integer;
  221.  
  222. Begin
  223.    Year := StrToInt ( copy ( S, 8, length ( S ) ) );
  224.  
  225.    Month := ValidMonth ( copy ( S, 4, 3 ) );
  226.    if Month = 0 then
  227.       begin
  228.       ValidDate := false;
  229.       exit;
  230.       end;
  231.  
  232.    Day := StrToInt ( S [ 1 ] + S [ 2 ] );
  233.    if ( LeapYear ( Year ) ) and ( Month = 2 ) then
  234.       ValidDate := Day <= ( NumDays [ Month ] + 1 )
  235.    else
  236.       ValidDate := Day <= NumDays [ Month ];
  237.  
  238. End;
  239.  
  240. {========================================================================}
  241.  
  242. Function LeapYear ( Year : integer ) : boolean;
  243.  
  244. Begin
  245.    LeapYear := (Year mod 4 = 0) and not ((Year mod 100 = 0)
  246.                                 and not ((Year mod 400 = 0)));
  247. End;
  248.  
  249. {========================================================================}
  250.  
  251. Function DateToJulian ( D : TDate ) : longint;
  252.  
  253. var
  254.    JD : longint;
  255.  
  256. Begin
  257.    if D.Year < 100 then  { assume 19th century }
  258.       inc ( D.Year, 1900 );
  259.    JD := (D.Month - 14) div 12;
  260.    JD := D.Day - 32075 + (1461 * (D.Year + 4800 + JD) div 4) +
  261.                          (367 * (D.Month - 2 - JD * 12) div 12) -
  262.                          (3 * ((D.Year + 4900 + JD) div 100) div 4);
  263.    DateToJulian := JD;
  264. End;
  265.  
  266. {========================================================================}
  267.  
  268. Procedure JulianToDate ( JD : longint; var Date : TDate );
  269.  
  270. var
  271.    TempA, TempB, TempC : longint;
  272.  
  273. Begin
  274.    TempA := JD + 68569;
  275.    TempB := 4 * TempA div 146097;
  276.    TempA := TempA - ( 146097 * TempB + 3 ) div 4;
  277.    Date.Year := 4000 * ( TempA + 1 ) div 1461001;
  278.    TempC := Date.Year;
  279.    TempA := TempA - ( 1461 * TempC div 4 ) + 31;
  280.    Date.Month := 80 * TempA div 2447;
  281.    TempC := Date.Month;
  282.    Date.Day := TempA - ( 2447 * TempC div 80 );
  283.    TempA := Date.Month div 11;
  284.    Date.Month := Date.Month + 2 - ( 12 * TempA );
  285.    Date.Year := 100 * ( TempB - 49 ) + Date.Year + TempA;
  286. End;
  287.  
  288. {========================================================================}
  289.  
  290. Function DayOfWeek ( D : TDate ) : integer;
  291. { Sunday=0, Monday=1, etc..., Saturday=6 }
  292. var
  293.    DW, Century : integer;
  294.  
  295. Begin
  296.    if D.Year < 100 then
  297.       inc ( D.Year, 1900 );
  298.    dec ( D.Month, 2 );
  299.    if ( D.Month < 1 ) or ( D.Month > 10 ) then
  300.       begin
  301.       inc ( D.Month, 12 );
  302.       dec ( D.Year );
  303.       end;
  304.    Century := D.Year div 100;
  305.    D.Year := D.Year mod 100;
  306.    DW := ( trunc ( int ( 2.6 * D.Month - 0.2 ) ) + D.Day + D.Year +
  307.          ( D.Year div 4 ) + ( Century div 4 ) - Century - Century ) mod 7;
  308.    if DW < 0 then
  309.       inc ( Dw, 7 );
  310.    DayOfWeek := DW;
  311. End;
  312.  
  313. {========================================================================}
  314.  
  315. Function DayOfWeekStr ( D : TDate ) : string;
  316.  
  317. const
  318.    DayNames : array [ 0..6 ] of string [ 10 ]
  319.               = ( 'Sunday', 'Monday', 'Tuesday', 'Wednesday',
  320.                   'Thursday', 'Friday', 'Saturday' );
  321. Begin
  322.    DayOfWeekStr := DayNames [ DayOfWeek ( D ) ];
  323. End;
  324.  
  325. {========================================================================}
  326.  
  327. End.